home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / forth_83.zoo / gem / supergem.scr < prev    next >
Text File  |  1992-04-07  |  16KB  |  1 lines
  1. \\                     *** SUPERGEM.SCR ***            16sep86we                                                                In diesem File soll eine GEM-Library aufgebaut werden, die      komfortablere Routinen als die Standardbefehle mit Ihren un-    übersehbaren Parametern zur Verfügung stellt.                                                                                   Bei der Entwicklung des Editors sind bereits einige solche      Routinen entstanden.                                                                                                            Für Anregungen gerade in diesem Bereich sind wir dankbar....                                                                                                                                                                                                                                                                                                                                                                                                    \ GEM-Library Loadscreen                               02nov86we                                                                Onlyforth  GEM also                                                                                                             \needs scr>mem  $10 loadfrom gem\vdi.scr                                                                                        Onlyforth  GEM also definitions                                                                                                 1 4 +thru                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                       \ Resource Trees and objects                           02sep86we                                                                : tree!   ( tree -- )                                              0 swap  rsrc_gaddr  objc_tree 2! ;                                                                                           : objc_gaddr   ( object# -- laddr )                                &24 *  extend  objc_tree 2@  d+  ;                                                                                           : text_gaddr   ( object# -- laddr )                                objc_gaddr   &12 extend  d+  l2@   l2@ ;                                                                                     : alert   ( n -- button )                                          show_c                                                          5 swap rsrc_gaddr addrin 2!  1 intin !  &52 1 1 1 AES           hide_c ;                                                                                                                     \ Move text to Objects and back                        02nov86we                                                                : putstring   ( addr object# -- )      >r                          count  under >r   >absaddr   r>  r@ text_gaddr  rot  lcmove     0 swap  extend  r> text_gaddr  d+ lc! ;                                                                                      : getstring   ( object# addr -- )      >r  text_gaddr              0  BEGIN  >r 2dup r@ extend d+ lc@  WHILE  r> 1+  REPEAT  r>    r>  2dup c!  1+ >absaddr  rot  lcmove ;                                                                                      : getnumber   ( object# -- d )                                     pad getstring   pad count bl skip  swap 1-   dup >r  c!         r@ capitalize  c@  IF  r> number  ELSE  rdrop 0 0  THEN ;                                                                    : putnumber   ( d object# -- )     >r                              <# #s #>  over 1- c!  1-   r> putstring ;                    \ init_object select deselect                          02nov86we                                                                Create little  &320 , &200 , &10 , &10 ,                        Create big     8 allot                                                                                                          : init_object   ( -- )                                              &320 &200 &10 &10 little 4!  form_center big 4! ;                                                                           : state_gaddr  ( object -- laddr )    objc_gaddr  &10. d+ ;                                                                     : select       ( object -- )          1 swap state_gaddr l! ;   : deselect     ( object -- )          0 swap state_gaddr l! ;                                                                                                                                                                                                                                                                   \ show_object hide_object objc_setpos objc_getwh       12aug86we                                                                : show_object   ( -- )   init_object                               big 4@  scr>mem1   1  little 4@  big 4@  form_dial              0 ( install) 3 ( depth)  big 4@ objc_draw show_c ;                                                                           : hide_object   ( -- )   hide_c                                    2  little 4@  big 4@  form_dial   big 4@  mem1>scr ;                                                                         : objc_setpos   ( x y object# -- )                                 dup >r  objc_gaddr  $0.12 d+ l!   r> objc_gaddr $0.10 d+ l! ;                                                                : objc_getwh    ( object# -- width height )                        dup  objc_gaddr  $0.14 d+ l@  swap objc_gaddr $0.16 d+ l@ ;                                                                                                                                  \                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                               \